home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE21 / SYSTEM / ResFile.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1997-04-04  |  8.8 KB  |  286 lines

  1. unit ResFile;
  2.  
  3. {----------------------------------------------------------------------------------
  4.     Name:     ResFile
  5.     Purpose:  Implementation of TResFile.  This version 16-bit (NE) only.
  6.     Author:   Dave Jewell, 1996-1997, ALL RIGHTS RESERVED.
  7.  ----------------------------------------------------------------------------------}
  8.  
  9. interface
  10.  
  11. uses WinTypes, WinProcs, Classes, SysUtils;
  12.  
  13. const
  14.     { Magic numbers }
  15.     DOS_Magic         = $5A4D;    { Magic word for old-style DOS EXE's    }
  16.     W16_Magic         = $454E;    { Magic word for new-style 16-bit EXE's }
  17.  
  18.     { Error messages - should really go in resources ... }
  19.     eFileNotFound    = 'File % not found';
  20.     eFileNotExe      = 'File % is not an executable';
  21.     eFileNotNE       = 'File % is not a Windows 16-bit (NE) executable';
  22.  
  23. type
  24.     EResFile = class (Exception);
  25.  
  26.     PResInfo = ^TResInfo;
  27.     TResInfo = record
  28.                     ROffset: LongInt;    { Offset of resource data }
  29.                     RLength: Word;       { Length of resource data }
  30.                     RFlags: Word;        { Flags for this resource }
  31.                  end;
  32.  
  33.     TResFile = class (TObject)
  34.     private
  35.         fName: String;
  36.         fMapNames: Boolean;
  37.         fHeaderPos: LongInt;
  38.         fTypesList: TStringList;
  39.         procedure Panic (const Message: String);
  40.         function MapResNumToString (const Name: String): String;
  41.         function MapStringToResNum (const Name: String): String;
  42.         function GetResList (const TypeName: String): TStringList;
  43.         function GetTypeName (Index: Integer): String;
  44.         function GetResourceTypeCount: Integer;
  45.     public
  46.         constructor Create (const FileName: String);
  47.         destructor Destroy;
  48.         property ResTypeCount: Integer read GetResourceTypeCount;
  49.         property ResTypes [Index: Integer]: string read GetTypeName;
  50.         property ResMapNames: Boolean read fMapNames write fMapNames;
  51.         function GetResourceCount (const TypeName: String): Integer;
  52.         function GetResourceName (const TypeName: String; Idx: Integer): String;
  53.         procedure GetResourceInfo (const TypeName: String; Idx: Integer; var Info: TResInfo);
  54.  
  55.     end;
  56.  
  57. implementation
  58.  
  59. constructor TResFile.Create (const FileName: String);
  60. var
  61.     fs: TFileStream;
  62.     ResShift, ResTablePos, ResTableSize: Word;
  63.  
  64.     function ReadByte: Byte;
  65.     begin
  66.         fs.Read (Result, sizeof (Result));
  67.     end;
  68.  
  69.     function ReadWord: Word;
  70.     begin
  71.         fs.Read (Result, sizeof (Result));
  72.     end;
  73.  
  74.     function ReadLong: LongInt;
  75.     begin
  76.         fs.Read (Result, sizeof (Result));
  77.     end;
  78.  
  79.     function ReadString: String;
  80.     var
  81.         Idx, i: Word;
  82.         OldPos: LongInt;
  83.     begin
  84.         Idx := ReadWord;  if Idx = 0 then Result := '' else
  85.         if (Idx and $8000) <> 0 then Result := Format ('#%d', [Idx and $7FFF])
  86.         else
  87.         begin
  88.             OldPos := fs.Position;
  89.             fs.Position := fHeaderPos + ResTablePos + Idx {- Ord (fType)};
  90.             Result [0] := Char (ReadByte);
  91.             for i := 1 to Ord (Result [0]) do Result [i] := Char (ReadByte);
  92.             fs.Position := OldPos;
  93.         end;
  94.     end;
  95.  
  96.     function ReadResourceList: Boolean;
  97.     var
  98.         ResType: String;
  99.         i, Count: Integer;
  100.         Res: ^TResInfo;
  101.         List: TStringList;
  102.     begin
  103.         Result := False;
  104.         ResType := ReadString;
  105.         if ResType <> '' then
  106.         begin
  107.             Result := True;
  108.             List := TStringList.Create;
  109.             { Count number of resources of this type }
  110.             Count := ReadWord;  ReadLong;
  111.             for i := 0 to Count - 1 do
  112.             begin
  113.                 GetMem (Res, sizeof (TResInfo));
  114.                 Res^.ROffset := LongInt (ReadWord) shl ResShift;
  115.                 Res^.RLength := ReadWord shl ResShift;
  116.                 Res^.RFlags := ReadWord;
  117.                 List.AddObject (ReadString, TObject (Res));
  118.                 ReadLong;
  119.             end;
  120.  
  121.             fTypesList.AddObject (ResType, List);
  122.         end;
  123.     end;
  124.  
  125.     procedure ReadResources;
  126.     var
  127.         ResType: Word;
  128.     begin
  129.         with fs do
  130.         begin
  131.             { Get the size and position of the resource table }
  132.             Position := fHeaderPos + $24; ResTablePos := ReadWord;
  133.             ResTableSize := ReadWord - ResTablePos;
  134.             { Stripping all resources with RW leaves a vestigial 4-byte table }
  135.             if ResTableSize > 4 then
  136.             begin
  137.                 Position := fHeaderPos + ResTablePos;
  138.                 ResShift := ReadWord;
  139.                 while ReadResourceList do ;
  140.             end;
  141.         end;
  142.     end;
  143.  
  144. begin
  145.     fName := FileName;
  146.     fMapNames := False;
  147.     fTypesList := TStringList.Create;
  148.     if not FileExists (FileName) then Panic (eFileNotFound);
  149.     fs := TFileStream.Create (FileName, fmOpenRead);
  150.     with fs do try
  151.         if ReadWord <> DOS_Magic then Panic (eFileNotExe);
  152.         Position := $3C; Position := ReadLong; fHeaderPos := Position;
  153.         if ReadWord <> W16_Magic then Panic (eFileNotNE);
  154.         { OK - We know it's a NE executable - now load what we're after }
  155.         ReadResources;
  156.     finally
  157.         fs.Free;
  158.     end;
  159. end;
  160.  
  161. destructor TResFile.Destroy;
  162. var
  163.     j: Integer;
  164.     TypeList: TStringList;
  165. begin
  166.     while fTypesList.Count > 0 do
  167.     begin
  168.         TypeList := TStringList (fTypesList.Objects [0]);
  169.         for j := 0 to TypeList.Count - 1 do
  170.             FreeMem (TypeList.Objects [j], sizeof (TResInfo));
  171.         TypeList.Free;
  172.         fTypesList.Delete (0);
  173.     end;
  174.  
  175.     fTypesList.Free;
  176. end;
  177.  
  178. procedure TResFile.Panic (const Message: String);
  179. var
  180.     p: Integer;
  181.     Str: String;
  182. begin
  183.     p := Pos ('%', Message);
  184.     if p = 0 then Str := Message
  185.     else Str := Copy (Message, 1, p - 1) + '"' + fName + '"' + Copy (Message, p + 1, 255);
  186.     raise EResFile.Create (Str);
  187. end;
  188.  
  189. function TResFile.GetResourceTypeCount: Integer;
  190. begin
  191.     Result := fTypesList.Count;
  192. end;
  193.  
  194. function TResFile.MapResNumToString (const Name: String): String;
  195. begin
  196.     Result := Name;
  197.     if (Result [1] = '#') and fMapNames then
  198.         case StrToInt (Copy (Result, 2, 255)) of
  199.             1:   Result := 'CURSOR';
  200.             2:   Result := 'BITMAP';
  201.             3:   Result := 'ICON';
  202.             4:   Result := 'MENU';
  203.             5:   Result := 'DIALOG';
  204.             6:   Result := 'STRINGTABLE';
  205.             7:   Result := 'FONTDIR';
  206.             8:   Result := 'FONT';
  207.             9:   Result := 'ACCELERATOR';
  208.             10:  Result := 'RCDATA';
  209.             12:  Result := 'GROUPCURSOR';
  210.             14:  Result := 'GROUPICON';
  211.             16:  Result := 'VERSIONINFO';
  212.         end;
  213. end;
  214.  
  215. function TResFile.MapStringToResNum (const Name: String): String;
  216. var
  217.     Num: Integer;
  218. begin
  219.     Num := -1;
  220.     if (Name [1] <> '#') and fMapNames then
  221.     begin
  222.         if Name = 'CURSOR' then     Num := 1;
  223.         if Name = 'BITMAP' then     Num := 2;
  224.         if Name = 'ICON' then         Num := 3;
  225.         if Name = 'MENU' then         Num := 4;
  226.         if Name = 'DIALOG' then     Num := 5;
  227.         if Name = 'STRINGTABLE'    then     Num := 6;
  228.         if Name = 'FONTDIR' then     Num := 7;
  229.         if Name = 'FONT' then         Num := 8;
  230.         if Name = 'ACCELERATOR' then     Num := 9;
  231.         if Name = 'RCDATA' then     Num := 10;
  232.         if Name = 'GROUPCURSOR' then     Num := 12;
  233.         if Name = 'GROUPICON' then     Num := 14;
  234.         if Name = 'VERSIONINFO' then     Num := 16;
  235.     end;
  236.  
  237.     if Num = -1 then Result := Name else Result := '#' + IntToStr (Num);
  238. end;
  239.  
  240. function TResFile.GetTypeName (Index: Integer): String;
  241. begin
  242.     Result := '';
  243.     if (Index >= 0) and (Index < fTypesList.Count) then
  244.         Result := MapResNumToString (fTypesList.Strings [Index]);
  245. end;
  246.  
  247. function TResFile.GetResList (const TypeName: String): TStringList;
  248. var
  249.     Idx: Integer;
  250. begin
  251.     Idx := fTypesList.IndexOf (MapStringToResNum (TypeName));
  252.     if Idx = -1 then Result := Nil
  253.     else Result := fTypesList.Objects [Idx] as TStringList;
  254. end;
  255.  
  256. function TResFile.GetResourceCount (const TypeName: String): Integer;
  257. var
  258.     List: TStringList;
  259. begin
  260.     List := GetResList (TypeName);
  261.     if List = Nil then Result := 0 else Result := List.Count;
  262. end;
  263.  
  264. function TResFile.GetResourceName (const TypeName: String; Idx: Integer): String;
  265. var
  266.     List: TStringList;
  267. begin
  268.     Result := '';
  269.     List := GetResList (TypeName);
  270.     if (List <> Nil) and (Idx >= 0) and (Idx < List.Count) then
  271.         Result := List.Strings [Idx]
  272. end;
  273.  
  274. procedure TResFile.GetResourceInfo (const TypeName: String; Idx: Integer; var Info: TResInfo);
  275. var
  276.     pInfo: PResInfo;
  277.     List: TStringList;
  278. begin
  279.     List := GetResList (TypeName);
  280.     if (List <> Nil) and (Idx >= 0) and (Idx < List.Count) then
  281.         Info := PResInfo (List.Objects [Idx])^;
  282. end;
  283.  
  284. end.
  285.  
  286.